COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 	DIMENSION ITX(18),JST(128),RN(200)
C00020 ENDMK
C⊗;
 	DIMENSION ITX(18),JST(128),RN(200)
	DATA ITX/'EF-','E-','F','GF','G','AF','A',
	1 'BF','B',0,'DF','D','EF','E','F+','BBF','O-','O+'/
C  O- = OCTAVE DOWN, O+ =OCTAVE UP.   OR 1/2 STEP NUMS. MAY BE USED.
	COMMON  /XXX/IRV,ITRANS,JPG
	COMMON /PX/KPN(250) /Q/Q(2000)
	EQUIVALENCE (ITEM,JST(18)),(ITOT,JST(19))
1000	FORMAT(' TYPE FILE NAME.EXT   ',$)
2200	FORMAT(A5,A1,A3)
2201	FORMAT(1XA5,'.',A3)
400	FORMAT(' OUTPUT NAME.EXT   ',$)
6	FORMAT(' WRITE OVER ',A5,'.',A3,'?  ',$)
8	FORMAT(A1)
304	FORMAT(' TRANSP.= '$)
306	FORMAT(I)
	SIG=-99
	XSIG=0
300	TYPE 1000
	ACCEPT 2200,NM,XIN,XIN
	NX=NM+256
2001	TYPE 304
	ACCEPT 2101,ITRANS
	IF(ITRANS.GT.-20)GO TO 1101
2101	FORMAT(A3)
C  NEXT FOR LETTER NAMES 
	DO 3101 K=1,18
3101	IF(ITRANS.EQ.ITX(K))GO TO 4101
5101	TYPE 240
	GO TO 2001
240	FORMAT(' THIS TRANSP NOT OFFERED')
1101	REREAD 306,ITRANS
	IF(ITRANS.EQ.0)GO TO 300
	ITRANS=10-ITRANS
	IF(ITRANS.EQ.22)ITRANS=17
C FOR DOWN OCT.
	IF(ITRANS.GT.0)GO TO 700
	IF(ITRANS.EQ.-2)ITRANS=18
C  -2 NOW = UP OCT.
	GO TO 700
4101	ITRANS=K
	
700	TYPE 400
	ACCEPT 2200,NOUT,K,XOUT
	IF(NOUT.NE.' ')GO TO 5
	NOUT='AAAAA'
	XOUT='TST'
C DEFAULT NAMES
5	IF(LOOKX(NOUT,XOUT).GE.0)GO TO 11
	TYPE 6,NOUT,XOUT
	ACCEPT 8,K
	IF(K.EQ.'N')GO TO 700
11	JOUT=NOUT+256
10	IF(LOOKX(NM,XIN))GO TO 9
	NM=NX
	NX=NX+256
C  WILL READ UP TO 52 FILES.
	NOUT=JOUT
	JOUT=JOUT+256
	IF(LOOKX(NM,XIN).GE.0)CALL EXIT

9	CALL GETEXT(NM,XIN)
	CALL EXTIN(JST,128)
	CALL EXTIN(KPN,ITEM)
	CALL EXTIN(Q,ITOT)
	TYPE 2201,NM,XIN
	ITEM=ITEM-2

C  NEXT SORTS INTO LEFT-TO-RIGHT
	KL=1
	JPG=ITEM-1
333	DO 33 K=KL,JPG 
	IF(CODEN(KPN,K,Q,J).GT.6)GO TO 33
	A=Q(J+3)
	DO 33 J=K+1,JPG
	IF(CODEN(KPN,J,Q,L).GT.6)GO TO 33
	IF(A.LE.Q(L+3))GO TO 33
	CALL EXCH(KPN(J),KPN(K))
	KL=J-1
	GO TO 333
33	CONTINUE

C NEXT FIND HOW MANY STAVES.  KSIG?
	RS=0
	DO 32 K=1,ITEM
	R=CODEN(KPN,K,Q,J)
	IF(R.GT.2)GO TO 32
	IF(Q(J+2).GT.RS)RS=Q(J+2)
32	IF(R.EQ.17)SIG=0
	JPG=RS+1
	JITEM=ITEM

	IOCT=0
	KW=0
C  FOUND KSIG, SO DON'T DO THE REST
	IF(XSIG.NE.0)GO TO 199 
	RT=0
	GO TO(94,94,93,92,92, 91,91,90,90,90, 97,97,96,96,95,
	1 102,99,98),ITRANS
C  EEb,EE,F↓,F#↓,G,  Ab,A,Bb,B,DMY,  Db,D,Eb,E,F  BBb, 8↓, 8↑
	RETURN
102	RT=8
	GO TO 41
95	RT=RT-1
96	RT=RT-1
97	RT=RT-1
	GO TO 41
98	RT=7
	GO TO 45
99	RT=-7
45	IOCT=-1
	GO TO 199
94	RT=RT+1
93	RT=RT+1
92	RT=RT+1
91	RT=RT+1
90	RT=RT+1
41	NSIG=-1
CC	IF(RSIG(KW).NE.99)GO TO 699
C  ASSUMES KSIG DESIRED IF ONE THERE ALREADY.
	IF(SIG.EQ.0)GO TO 699
	TYPE 42
42	FORMAT(' ADD KEY SIG? -- ',$)
	ACCEPT 8,XSIG
299	IF(XSIG.NE.'Y')GO TO 199
699	NSIG=0
	XSIG=99

C  ***** NEXT FOR KEY SIG. ********
399	IADD=0
C  ADD= ADD OR SUBTR. # OR b  FROM KSIG.
	GO TO (73,78,75,76,81, 72,79,74,77,399,
	1 71,80,73,78,75, 74),ITRANS
C  EEb,EE,F↓,F#↓,G,  Ab,A,Bb,B,DMY,  Db,D,Eb,E,F  BBb, 8↓, 8↑
71	IADD=IADD+1
72	IADD=IADD+1
73	IADD=IADD+1
74	IADD=IADD+1
75	IADD=IADD+1
C 75=F, 81=G, 79=A, 73=E FLAT, 74=Bb, 80=D
CC	GO TO 2002
	GO TO 199
76	IADD=IADD-1
77	IADD=IADD-1
78	IADD=IADD-1
79	IADD=IADD-1
80	IADD=IADD-1
81	IADD=IADD-1
CC2002	K=0
CC2003	R=0
CC	RZ=RSIG(K)
CC	IF(RZ.NE.-99)R=RZ
CC	R=IADD+R
CC	IF(R.EQ.0)GO TO 799
CC	IF(IPG.GT.0)GO TO 799
C SKIP IF TRNSP ONLY.
CC	IF(RZ.EQ.-99)CALL STAFF
CC	1 (4.,17.,4.0*RSTJ2,0,R,CLEF,0,0,0,0,0,0)
CC799	RSIG(K)=R
CC	K=K+1
CC	IF(K.LT.JPG)GO TO 2003
199	K=1
	CLEF=-1
	RSIG=0
	SLUR=0
	PRX=99
	MS=1
	SN=KW
599	X=CODEN(KPN,K,Q,J)
	IF(X.NE.4)GO TO 2
	BAR=-1
	MS=1  
	GO TO 100
2	IF(Q(J+2).NE.SN)GO TO 100
CHECK FOR STAFF NUM.
	IF(X.EQ.1)GO TO 1
20	IF(X.NE.17)GO TO 12
	RSIG=-1
	R=Q(J+5)
C KSIG NUM.
	X=R+IADD
CHANGED TO X
	IF(X.NE.0)GO TO 23
CC	X=100
CHANGE KSIG TO NATURALS
CC	IF(R)X=-X
CC	X=R+X
	M=Q(J)+3
C THIS WILL DELETE KSIG
	ITOT=ITOT-M
	KL=ITOT-J
	CALL RLOOP(Q(J),Q(J+M),KL)
	DO 334 J=K,JITEM
334	KPN(J)=KPN(J+1)-M
	JITEM=JITEM-1
	K=K-1
	GO TO 100
23	Q(J+5)=X
	NSIG=0
12	IF(X.EQ.5)GO TO 120
	IF(X.NE.3)GO TO 26
	IF(CLEF.GE.0)GO TO 100
C FINDS ONLY 1 CLEF PER STAFF
	CLEF=Q(J+5)
	IF(Q(J).LT.3)CLEF=0
	GO TO 100
26	IF(X.NE.6)GO TO 100
120	IF(RT.NE.8)GO TO 121
	IF(CLEF.EQ.1)RT=-4
121	Q(J+4)=Q(J+4)+RT
	Q(J+5)=Q(J+5)+RT
	IF(X.EQ.5)SLUR=Q(J+6)
C  SAVES RIGHT POS. OF SLUR
	GO TO 100
C  FOR BEAMS AND SLURS

1	R=Q(J+4)
	XRT=RT
	IF(IOCT)GO TO 4
C  IOCT=-1 FOR OCT+ OR OCT- 
	RX=AMOD(R,100.0)
	RZ=AMOD(RX,7.0)
C  THE NOTE NUM
	IF(RZ)RZ=RZ+7
C  PUTS IT IN 0-6 RANGE FOR ACCI CHANGE SECTION.
	R5=Q(J+5)
	A=AMOD(R5,10.0)
C  THE ACCI
	RN(MS)=A
	RN(MS+1)=RX
C  SAVE FOR REPEATS
	MS=MS+2
	CHNAT=3
	IF(MS.LT.4)GO TO 205
CC	IF(MS.LT.203)GO TO 205
	N=MS-3
200	IF(RX.NE.RN(N))GO TO 201
	IF(A.EQ.0)GO TO 4
C  NOW WE'VE FOUND THE SAME NOTE WITH NO ACCI IN SAME MEAS.
	GO TO 203
CC204	IF(CLEF.EQ.1)RT=RT-12
C  FOR BSCLAR
CC	IF(A.NE.0)GO TO 203
CC	GO TO 4
201	N=N-2
	IF(N.GE.1)GO TO 200
CC	IF(N.GE.200)GO TO 200
205	IF(NSIG)CHNAT=0
203	ADD=A
C  THE CHANGE IN ACCI
	IF(PRX.NE.RX)GO TO 44
C IF PREV ACCI AND NT ARE SAME, SKIP OVER.
	IF(A.NE.0)GO TO 44
C NOW SAME NOTE, NO ACCI
	IF(ABS(SLUR-Q(J+3)).GT.3)GO TO 44
C  FOUND CONNECTING TIE
CC	IF(BAR.EQ.0)GO TO 204
C THIS ↑↑↑↑ ALWAYS PUTS ACCI AFTER A BAR -- EVEN WITH TIE------
C OR SET MS BACK TO 200 WHEN TIE IS PRESENT.  THIS WILL
CAUSE LATER SAME NOTE TO HAVE ACCI (I HOPE.)
	IF(BAR)MS=1  
	IF(A.NE.0)GO TO 203
	GO TO 4
44	IF(NSIG)GO TO 440
	IF(ITRANS.GE.16)GO TO 69
	IF(A.EQ.0)GO TO 4
C  ONLY CHECKS ON NOTES WITH NO ACCI

440	IF(CLEF.NE.1)GO TO 69
	RZ=RZ-5
	IF(RZ)RZ=RZ+7
69	GO TO (63,52,53,54,55, 56,57,58,59,440, 61,62,63,52,53
	1 ,64),ITRANS
C  EEb,EE,F↓,F#↓,G,  Ab,A,Bb,B,DMY,  Db,D,Eb,E,F  BBb
54	IF(RZ.EQ.3)GO TO 101
59	IF(RZ.EQ.6)GO TO 101
52	IF(RZ.EQ.2)GO TO 101
57	IF(RZ.EQ.5)GO TO 101
C  FOR "A".  FINDS C,F AND G.
62	IF(RZ.EQ.1)GO TO 101
55	IF(RZ.EQ.4)GO TO 101
C  "G"   F→Bb, F#→B NAT.
	GO TO 4
61	IF(RZ.EQ.5)GO TO 7
56	IF(RZ.EQ.2)GO TO 7
63	IF(RZ.EQ.6)GO TO 7
58	IF(RZ.EQ.3)GO TO 7
53	IF(RZ.NE.0)GO TO 4
	
7	IF(A.EQ.0)GO TO 402
	IF(A.EQ.3)GO TO 402
C  CHNG NO ACCI OR NAT TO SHARP
	IF(A.EQ.4)GO TO 401
C 4=bb   5=##
	IF(A.EQ.2)GO TO 405
30	ADD=CHNAT
C  MAKE IT NAT. IF NEEDED
3	Q(J+5)=R5-A+ADD
4	PRX=RX
C  REAL NOTE LEVEL
	Q(J+4)=R+XRT
	BAR=0
100	IF(K.GE.JITEM)GO TO 499
	K=K+1
	GO TO 599


C NEXT FOR BSCLAR.---ADD OTHERS HERE!!!
64	IF(CLEF.EQ.1)XRT=XRT-12
	GO TO 58

101	IF(A.EQ.0)GO TO 401
	IF(A.EQ.2)GO TO 30
	IF(A.EQ.3)GO TO 401
	IF(A.EQ.5)GO TO 402
C  WON'T HANDLE Gbb→Ab
404	ADD=4
	GO TO 3
401	ADD=1
	GO TO 3

402	ADD=2
	GO TO 3
405	ADD=5
	GO TO 3
499	KW=KW+1
	IF(RSIG)GO TO 498
	IF(IADD.EQ.0)GO TO 498
	M=ITOT-1
C INSERT NEW KSIG
	Q(M)=4
	Q(M+1)=17
	Q(M+2)=SN
	Q(M+3)=9 
	Q(M+4)=0 
	Q(M+5)=IADD
	Q(M+6)=CLEF
	ITOT=ITOT+7
	JITEM=JITEM+1
	KPN(JITEM)=ITOT+1
498	IF(KW.LT.JPG)GO TO 199
	CALL RVRS(JITEM)
C  TO REVERSE STEMS, BEAMS AND SLURS
497	DO 496 K=1,ITEM-1
C THIS REORDERS PTR ARRAY
	IF(KPN(K).LT.KPN(K+1))GO TO 496
	CALL EXCH(KPN(K),KPN(K+1))
	GO TO 497
496	CONTINUE
	CALL PUTEXT(NOUT,XOUT)
	ITEM=JITEM+2
	CALL EXTOUT(JST,128)
	CALL EXTOUT(KPN,ITEM)
	CALL EXTOUT(Q,ITOT)
	CALL FINEXT
	TYPE 2201,NOUT,XOUT
	NOUT=NOUT+2
	NM=NM+2
	GO TO 10
	END



	SUBROUTINE RVRS(LEND)
	COMMON /PX/KPN(1) /Q/Q(1)
 	1 /XXX/IRV,ITRANS,JPG
	DATA RSTEM/6.5/
	KW=0
	IRV=0
	IF(ITRANS.LT.10)GO TO 100
	IF(ITRANS.NE.18)IRV=-1
C TRNS ↓ + STEM ↑ = NO CHNG, TRNS ↑ +STEM ↓ = NO CHNG
100	K=1
	SN=KW
	DO 30 N=1,LEND
	IF(CODEN(KPN,N,Q,J).NE.1)GO TO 30
C LOOK FOR NOTES WITH STEM BUT NO RHYTH. VALUE
	IF(Q(J+2).NE.SN)GO TO 30
C ON THIS STAFF?
	IF(Q(J).LT.7)GO TO 31
	IF(Q(J+9).NE.0)GO TO 30
31	IF(Q(J+5).GE.10)GO TO 102
C FOUND A 0 RHYTHM WITH A STEM - IGNORE THIS STAFF
30	CONTINUE

1	R=CODEN(KPN,K,Q,J)
	IF(Q(J+2).NE.SN)GO TO 10
CHECK ON STAFF NUM.
	IF(R.NE.1)GO TO 2
C  JUMP IF NOT A NOTE
	IF(NORVRS(Q(J+5)))GO TO 10
CHECKS STEM DIR. AND TRNS DIR.
	IF(Q(J+5).LT.10)GO TO 10
C  JUMP IF NO STEM ON IT
	KK=K+1
3	IF(KK.GT.LEND)GO TO 102
CC3	IF(KK.GT.LEND)RETURN
	RR=CODEN(KPN,KK,Q,JJ)
	IF(Q(JJ+2).EQ.SN)GO TO 101
	GO TO 7
101	IF(RR.NE.1)GO TO 5
C  JUMP IF NOT A NOTE
	IF(Q(JJ+5).GE.10)GO TO 6
C SKIP CHORD NOTES (NO STEM)
7	KK=KK+1
	GO TO 3
C DID NOT FIND BEAM NEARBY
6	RZ=AMOD(Q(J+4),100.0)
	N=J+5
	A=10
	IF(RZ.GE.7)GO TO 60
	IF(Q(N).LT.20)GO TO 10
C NOW STEM SHOULD BE DOWN IF WITHOUT BEAM OR 1ST NT UNDER BEAM.
	A=-A
	GO TO 15
60	IF(Q(N).GE.20)GO TO 10
C  THERE MUST BE A BETTER WAY!
15	Q(N)=Q(N)+A
	GO TO 10
CCCCC8	IF(Q(N).LT.20)GO TO 10
CCCCC	A=-A
C  STEM UP
CCCCC	GO TO 15
5	IF(RR.NE.6)GO TO 6
20	B=Q(JJ+4)
	C=Q(JJ+5)
	D=(B+C)/2.
	IF(RR.EQ.5)GO TO 9
	IF(RR.NE.6)GO TO 10
	B=Q(JJ+6)+.5
C  SAVES RANGE OF BEAM +1.
	IF(Q(JJ+7).GE.20)GO TO 11
C  NOW STEMS ARE UP
	IF(D.LT.RSTEM)GO TO 12
C JUMP TO 12 IF ALL OK
CC	C=-10
	JSTM=0 
C SAVE FOR REVERSED STEMS
	GO TO 23
11	IF(D.GE.RSTEM)GO TO 12
C  STEMS DOWN
C JUMP IF NO REVERSE NEEDED
	JSTM=-1
23	JH=0
	CHNG=0
CC	DO 16 N=K,LEND
	N=K
164	R=CODEN(KPN,N,Q,KK)
	IF(Q(KK+2).NE.SN)GO TO 16
	IF(Q(KK+3).GT.B)GO TO 140
	IF(R.NE.1)GO TO 17
	L=5+KK
	IF(Q(L).LT.10)GO TO 16
C  PASS NOTES WITH NO STEM
	R=Q(KK+8)
C  THE STEM LENGTH
	IF(R.EQ.999)R=0
	Q(KK+8)=-R
C  FOR THE INVERSION
19	BC=10.
	A=Q(L)
	IF(A.GE.20)BC=-BC
	Q(L)=BC+A
	IF(JH.NE.0)GO TO 161
C NEXT FOR 1ST NOTE UNDER BEAM
	JH=4
160	R=Q(JJ+JH)-Q(KK+4)
	A=-1 
	IF(JSTM)GO TO 163
	A=R
	R=1
C NOW STEMS UP
163	IF(R.GT.A)GO TO 162
C JUMP IF BEAM IS NOT TOO CLOSE TO NOTE
	CHNG=A-R
	IF(JSTM.EQ.0)CHNG=-CHNG
CCC	JH=JJ+4
CCC	Q(JH)=Q(JH)+CHNG
CCC	JH=JH+1
CCC	Q(JH)=Q(JH)+CHNG
162	IF(L)GO TO 141
C  FOR ESCAPE FROM LOOP
161	JH=KK
C  JH SAVES PTR TO LAST NOTE UNDER BEAM
	GO TO 16
17	IF(R.NE.6)GO TO 18
C NOW IT'S A BEAM
	L=7+KK
	GO TO 19
18	IF(R.NE.5)GO TO 16
C NOW IT'S A SLUR
	C=-4
	IF(Q(KK+7))C=-C
	CALL SLRV(KK,C)
C  TO REVERSE SLUR
CC	Q(KK+7)=-Q(KK+7)
16	N=N+1
	IF(N.LE.LEND)GO TO 164
C  SHOULD ALWAYS EXIT FROM LOOP BEFORE END OF ARRAY!
140	KK=JH
	L=-1
	JH=5
C GO BACK TO CHECK HGT OF LAST NOTE AND RIGHT END OF BEAM
	GO TO 160

141	IF(CHNG.EQ.0)GO TO 14
	C=CHNG
	IF(CHNG)CHNG=-CHNG
	DO 142 N=K,LEND
C  TO READJUST STEMS UNDER REVERSED BEAMS
	R=CODEN(KPN,N,Q,KK)
	IF(Q(KK+2).NE.SN)GO TO 142
	IF(Q(KK+3).GT.B)GO TO 14
	IF(R.NE.1)GO TO 242
	Q(KK+8)=Q(KK+8)+CHNG
C  THE STEM LENGTH
	GO TO 142
242	IF(R.NE.6)GO TO 142
	Q(KK+4)=Q(KK+4)+C
	Q(KK+5)=Q(KK+5)+C
CC	Q(KK+7)=Q(KK+7)+BC  
142	CONTINUE
	GO TO 14

C NEXT FOR SLURS
9	B=-4
	IF(Q(JJ+7))GO TO 24
	IF(D.GT.RSTEM)GO TO 10
C JUMP TO LEAVE STEM UP
	GO TO 25
24	IF(D.LT.5)GO TO 10
C JUMP TO LEAVE STEM DOWN
	B=-B
CC25	Q(JJ+4)=Q(JJ+4)+B
CC	Q(JJ+5)=Q(JJ+5)+B
CC	Q(JJ+7)=-R
25	CALL SLRV(JJ,B)
	GO TO 10
12	DO 13 N=K+1,LEND
	KK=KPN(N)
	IF(Q(KK+2).NE.SN)GO TO 13
C  IS THIS NEEDED↑↑↑↑??
	IF(Q(KK+3).GT.B)GO TO 14
13	CONTINUE
C  JUMP OUT WHEN PAST END OF BEAM.
14	IF(N.GT.K)K=N-1
C          ↑↑↑↑↑↑   WHY????????????
	GO TO 10

2	IF(R.NE.6)GO TO 21
	IF(NORVRS(Q(J+7)))GO TO 10
22	JJ=J
	RR=R
	GO TO 20
21	IF(R.NE.5)GO TO 10
	RR=20
	IF(Q(J+7))RR=10
	IF(NORVRS(RR).GE.0)GO TO 22
10	IF(K.GT.LEND)GO TO 102
CC10	IF(K.GT.LEND)RETURN
	K=K+1
	GO TO 1
102	KW=KW+1
	IF(KW.LT.JPG)GO TO 100
	END

	FUNCTION NORVRS(R)
	COMMON  /XXX/IRV,ITRANS,JPG
	NORVRS=0
	IF(R.LT.20)GO TO 1
C NOW STEM UP
	IF(IRV)RETURN
2	NORVRS=-1
	RETURN
1	IF(IRV)GO TO 2
	END